home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / amigaunits / amigalib.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-01-01  |  6.5 KB  |  249 lines
  1. {
  2.     This file is part of the Free Pascal run time library.
  3.  
  4.     A file in Amiga system run time library.
  5.     Copyright (c) 1998-2000 by Nils Sjoholm
  6.     member of the Amiga RTL development team.
  7.  
  8.     See the file COPYING.FPC, included in this distribution,
  9.     for details about the copyright.
  10.  
  11.     This program is distributed in the hope that it will be useful,
  12.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14.  
  15.  **********************************************************************}
  16.  
  17. {
  18.     History:
  19.  
  20.     Added DoMethodA, DoSuperMethodA, CoerceMethodA and SetSuperAttrsA.
  21.  
  22.     I've translated those from amigae. I'm not sure that they are
  23.     correct but it's a start. Now you can try to make some tests
  24.     with mui.
  25.  
  26.     30 Jul 2000.
  27.  
  28.     nils.sjoholm@mailbox.swipnet.se
  29. }
  30.  
  31. unit amigalib;
  32.  
  33. INTERFACE
  34.  
  35. uses exec,intuition,utility;
  36.  
  37. {*  Exec support functions from amiga.lib  *}
  38.  
  39. procedure BeginIO (ioRequest: pIORequest);
  40. function CreateExtIO (port: pMsgPort; size: Longint): pIORequest;
  41. procedure DeleteExtIO (ioReq: pIORequest);
  42. function CreateStdIO (port: pMsgPort): pIOStdReq;
  43. procedure DeleteStdIO (ioReq: pIOStdReq);
  44. function CreatePort (name: STRPTR; pri: integer): pMsgPort;
  45. procedure DeletePort (port: pMsgPort);
  46. function CreateTask (name: STRPTR; pri: longint; 
  47.                      initPC : Pointer;
  48.              stackSize : ULONG): pTask; 
  49. procedure DeleteTask (task: pTask);
  50. procedure NewList (list: pList);
  51.  
  52. function DoMethodA(obj : pObject_; msg : APTR): ulong;
  53. function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
  54. function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
  55. function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong;
  56.  
  57. IMPLEMENTATION
  58.  
  59. {*  Exec support functions from amiga.lib  *}
  60.  
  61. procedure BeginIO (ioRequest: pIORequest);
  62. begin
  63.    asm
  64.       move.l  a6,-(a7)
  65.       move.l  ioRequest,a1    ; get IO Request
  66.       move.l  20(a1),a6      ; extract Device ptr
  67.       jsr     -30(a6)        ; call BEGINIO directly
  68.       move.l  (a7)+,a6
  69.    end;
  70. end;
  71.  
  72. function CreateExtIO (port: pMsgPort; size: Longint): pIORequest;
  73. var
  74.    IOReq: pIORequest;
  75. begin
  76.     IOReq := NIL;
  77.     if port <> NIL then
  78.     begin
  79.         IOReq := AllocMem(size, MEMF_CLEAR or MEMF_PUBLIC);
  80.         if IOReq <> NIL then
  81.         begin
  82.             IOReq^.io_Message.mn_Node.ln_Type   := NT_REPLYMSG;
  83.             IOReq^.io_Message.mn_Length    := size;
  84.             IOReq^.io_Message.mn_ReplyPort := port;
  85.         end;
  86.     end;
  87.     CreateExtIO := IOReq;
  88. end;
  89.  
  90.  
  91. procedure DeleteExtIO (ioReq: pIORequest);
  92. begin
  93.     if ioReq <> NIL then
  94.     begin
  95.         ioReq^.io_Message.mn_Node.ln_Type := $FF;
  96.         ioReq^.io_Message.mn_ReplyPort    := pMsgPort(-1);
  97.         ioReq^.io_Device                  := pDevice(-1);
  98.         ExecFreeMem(ioReq, ioReq^.io_Message.mn_Length);
  99.     end
  100. end;
  101.  
  102.  
  103. function CreateStdIO (port: pMsgPort): pIOStdReq;
  104. begin
  105.     CreateStdIO := pIOStdReq(CreateExtIO(port, sizeof(tIOStdReq)))
  106. end;
  107.  
  108.  
  109. procedure DeleteStdIO (ioReq: pIOStdReq);
  110. begin
  111.     DeleteExtIO(pIORequest(ioReq))
  112. end;
  113.  
  114.  
  115. function CreatePort (name: STRPTR; pri: integer): pMsgPort;
  116. var
  117.    port   : pMsgPort;
  118.    sigbit : shortint;
  119. begin
  120.     port  := NIL;
  121.     sigbit := AllocSignal(-1);
  122.     if sigbit <> -1 then
  123.     begin
  124.         port := AllocMem(sizeof(tMsgPort), MEMF_CLEAR or MEMF_PUBLIC);
  125.         if port = NIL then
  126.             FreeSignal(sigbit)
  127.         else
  128.             begin
  129.                 port^.mp_Node.ln_Name  := name;
  130.                 port^.mp_Node.ln_Pri   := pri;
  131.                 port^.mp_Node.ln_Type  := NT_MSGPORT;
  132.  
  133.                 port^.mp_Flags    := PA_SIGNAL;
  134.                 port^.mp_SigBit   := sigbit;
  135.                 port^.mp_SigTask  := FindTask(NIL);
  136.  
  137.                 if name <> NIL then
  138.                     AddPort(port)
  139.                 else
  140.                     NewList(@port^.mp_MsgList);
  141.             end;
  142.     end;
  143.     CreatePort := port;
  144. end;
  145.  
  146.  
  147. procedure DeletePort (port: pMsgPort);
  148. begin
  149.     if port <> NIL then
  150.     begin
  151.         if port^.mp_Node.ln_Name <> NIL then
  152.             RemPort(port);
  153.  
  154.         port^.mp_SigTask       := pTask(-1);
  155.         port^.mp_MsgList.lh_Head  := pNode(-1);
  156.         FreeSignal(port^.mp_SigBit);
  157.         ExecFreeMem(port, sizeof(tMsgPort));
  158.     end;
  159. end;
  160.  
  161.  
  162. function CreateTask (name: STRPTR; pri: longint;
  163.         initPC: pointer; stackSize: ULONG): pTask;
  164. var
  165.    memlist : pMemList;
  166.    task    : pTask;
  167.    totalsize : Longint;
  168. begin
  169.     task  := NIL;
  170.     stackSize   := (stackSize + 3) and not 3;
  171.     totalsize := sizeof(tMemList) + sizeof(tTask) + stackSize;
  172.  
  173.     memlist := AllocMem(totalsize, MEMF_PUBLIC + MEMF_CLEAR);
  174.     if memlist <> NIL then begin
  175.        memlist^.ml_NumEntries := 1;
  176.        memlist^.ml_ME[0].me_Un.meu_Addr := Pointer(memlist + 1);
  177.        memlist^.ml_ME[0].me_Length := totalsize - sizeof(tMemList);
  178.  
  179.        task := pTask(memlist + sizeof(tMemList) + stackSize);
  180.        task^.tc_Node.ln_Pri := pri;
  181.        task^.tc_Node.ln_Type := NT_TASK;
  182.        task^.tc_Node.ln_Name := name;
  183.        task^.tc_SPLower := Pointer(memlist + sizeof(tMemList));
  184.        task^.tc_SPUpper := Pointer(task^.tc_SPLower + stackSize);
  185.        task^.tc_SPReg := task^.tc_SPUpper;
  186.  
  187.        NewList(@task^.tc_MemEntry);
  188.        AddTail(@task^.tc_MemEntry,@memlist^.ml_Node);
  189.  
  190.        AddTask(task,initPC,NIL) 
  191.     end;
  192.     CreateTask := task;
  193. end;
  194.  
  195.  
  196. procedure DeleteTask (task: pTask);
  197. begin
  198.     RemTask(task)
  199. end;
  200.  
  201.  
  202. procedure NewList (list: pList);
  203. begin
  204.     with list^ do
  205.     begin
  206.         lh_Head     := pNode(@lh_Tail);
  207.         lh_Tail     := NIL;
  208.         lh_TailPred := pNode(@lh_Head)
  209.     end
  210. end;
  211.  
  212. function DoMethodA(obj : pObject_; msg : APTR): ulong;
  213. var
  214.     o : p_Object;
  215. begin
  216.     if assigned(obj) then begin
  217.        o := p_Object(obj);
  218.        DoMethodA := CallHookPkt(@o^.o_Class^.cl_Dispatcher, obj,msg);
  219.     end else DoMethodA := 0;
  220. end;
  221.  
  222. function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
  223. begin
  224.     if assigned(obj) and assigned(cl) then
  225.        DoSuperMethodA := CallHookPkt(@cl^.cl_Super^.cl_Dispatcher,obj,msg)
  226.     else DoSuperMethodA := 0;
  227. end;
  228.  
  229. function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
  230. begin
  231.     if assigned(cl) and assigned(obj) then
  232.        CoerceMethodA := CallHookPkt(@cl^.cl_Dispatcher,obj,msg)
  233.     else CoerceMethodA := 0;
  234. end;
  235.  
  236. function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong;
  237. var
  238.     arr : array[0..2] of longint;
  239. begin
  240.     arr[0] := OM_SET;
  241.     arr[1] := longint(msg);
  242.     arr[2] := 0;
  243.     SetSuperAttrsA := DoSuperMethodA(cl, obj, @arr);
  244. end;    
  245.  
  246. end.
  247.  
  248.  
  249.